home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / GRAPHICS.SWG / 0001_DOTSPIN.PAS.pas next >
Pascal/Delphi Source File  |  1993-05-28  |  3KB  |  108 lines
  1. program dotspin;
  2.  
  3. var inPort1:word;
  4. procedure waitRetrace;assembler;asm
  5.  mov dx,inPort1; {find crt status reg (input port #1)}
  6. @L1: in al,dx; test al,8; jnz @L1;  {wait for no v retrace}
  7. @L2: in al,dx; test al,8; jz @L2; {wait for v retrace}
  8.  end;
  9.  
  10. const
  11.  tableWriteIndex=$3C8;
  12.  tableDataRegister=$3C9;
  13.  
  14. procedure setColor(color,r,g,b:byte);assembler;asm {set DAC color}
  15.  mov dx,tableWriteIndex; mov al,color; out dx,al; inc dx;
  16.  mov al,r; out dx,al; mov al,g; out dx,al; mov al,b;out dx,al;
  17.  end; {write index now points to next color}
  18.  
  19. {plot a pixel in mode $13}
  20. procedure plot(x,y:word);Inline(
  21.   $5E/                   { pop si  ;y}
  22.   $5F/                   { pop di  ;x}
  23.   $B8/$00/$A0/           { mov ax,$A000}
  24.   $8E/$C0/               { mov es,ax}
  25.   $B8/$40/$01/           { mov ax,320}
  26.   $F7/$E6/               { mul si}
  27.   $01/$C7/               { add di,ax}
  28.   $26/$F6/$15);          {es: not byte[di]}
  29.  
  30. procedure plot4(x,y:word);const f=60;begin
  31.  plot(x+f,y);
  32.  plot(199+f-x,199-y);
  33.  plot(199+f-y,x);
  34.  plot(y+f,199-x);
  35.  end;
  36.  
  37. procedure click;assembler;asm
  38.  in al,$61; xor al,2; out $61,al;
  39.  end;
  40.  
  41. const nDots=21;
  42.  
  43. var
  44.  dot:array[0..nDots-1]of record
  45.   x,y,sx,sy:integer;
  46.   end;
  47.  
  48. function colorFn(x:integer):byte;begin
  49.  colorFn:=63-(abs(100-x)div 2);
  50.  end;
  51.  
  52. procedure moveDots;var i:word;begin
  53.  for i:=0 to nDots-1 do with dot[i] do begin
  54.   plot4(x,y);
  55.   inc(x,sx);inc(y,sy);
  56.   if(word(x)>200)then begin
  57.    sx:=-sx;inc(x,sx);click;
  58.    end;
  59.   if(word(y)>199)then begin
  60.    sy:=-sy;inc(y,sy);click;
  61.    end;
  62.   plot4(x,y);
  63.   end;
  64.  waitRetrace;waitRetrace;waitRetrace;{waitRetrace;}
  65.  setcolor(255,colorFn(dot[0].x),colorFn(dot[3].x),colorFn(dot[6].x));
  66.  end;
  67.  
  68. procedure drawdots;var i:word;begin
  69.  for i:=0 to nDots-1 do with dot[i] do plot4(x,y);
  70.  end;
  71.  
  72. procedure initDots;var i,j,k:word;begin
  73.  j:=1;k:=1;
  74.  for i:=0 to nDots-1 do with dot[i] do begin
  75.   x:=100;y:=99;
  76.   sx:=j;sy:=k;
  77.   inc(j);if j>=k then begin j:=1;inc(k); end;
  78.   end;
  79.  end;
  80.  
  81. function readKey:char;Inline(
  82.   $B4/$07/               {mov ah,7}
  83.   $CD/$21);              {int $21}
  84.  
  85. function keyPressed:boolean;Inline(
  86.   $B4/$0B/               {mov ah,$B}
  87.   $CD/$21/               {int $21}
  88.   $24/$FE);              {and al,$FE}
  89.  
  90. begin
  91.  inPort1:=memw[$40:$63]+6;
  92.  port[$61]:=port[$61]and (not 1);
  93.  setcolor(255,60,60,63);
  94.  initDots;
  95.  asm mov ax,$13; int $10; end;
  96.  drawDots;
  97.  repeat moveDots until keypressed;
  98.  readkey;
  99.  drawDots;
  100.  asm mov ax,3; int $10; end;
  101.  end.
  102.  
  103.  
  104.  * OLX 2.2 * Printers do it without wrinkling the sheets.
  105.  
  106. --- Maximus 2.01wb
  107.  * Origin: >>> Sun Mountain BBS <<< (303)-665-6922 (1:104/123)
  108.